HPAVC/HPAVC CD-ROM.iso/pc/2924.ZIP/DMLXREF.ARC/NUM.IMP

Text File | 1988-12-20 | 28.9 KB | 1,027 lines

(**************************************************************************)
(*                                                                        *)
(*          1)  General Numeric Formatting And Conversion                 *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

CONST

  S_INT = 1;  (* flag for INTEGER arg to Num2S *)
  L_INT = 2;  (* flag for LONGINT arg to Num2S *)

TYPE
  VarType = BYTE;  (* values: 1=INTEGER, 2=LONGINT   see CONST S_INT & L_INT *)

{.PA}


{=- NumLow1_ConvertMask -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}

FUNCTION NumLow1_ConvertMask (Mask     : STRING;
                              Negative : BOOLEAN;
                              RealMask : BOOLEAN): STRING;

{RealMask must be TRUE to allow the decimal character in the mask, and it must
 be set to FALSE to allow H (Hexidecimal) or B (Binary) in the mask.}

{Destroys local copy of Mask}

VAR
  MaskLength  : INTEGER;
  Ctr         : INTEGER;
  ConvertChar : CHAR;
  Error       : BOOLEAN;
  DecimalPos  : INTEGER;

  PROCEDURE CaseStatement (Selector : INTEGER);
  BEGIN
    CASE Mask [Selector] OF
      '(',
      ')',
      '-' : IF NOT Negative THEN Mask [Selector] := ' ';
      '+' : IF Negative     THEN Mask [Selector] := '-';
  'H','h',
  'B','b' : IF RealMask THEN Error := TRUE ELSE Mask [Selector] := ConvertChar;
      '#' : Mask [Selector] := ConvertChar;
      '*' : IF ConvertChar = '#' THEN ConvertChar     := '*'
                                 ELSE Mask [Selector] := ConvertChar;
      '@' : BEGIN
              ConvertChar := '0';
              Mask [Selector]  := '0';
              END;
      '.',
      ' ',
      ',',
      '$' : ; {Allow any number and placement of these chars!}
      ELSE Error := TRUE;
      END; {Case}
  END;

BEGIN
  MaskLength  := LENGTH (Mask);
  Error       := FALSE;

  DecimalPos := POS ('.', Mask);
  Error := (NOT RealMask) AND (DecimalPos <> 0);
  IF DecimalPos = 0 THEN DecimalPos := LENGTH (Mask);

  IF NOT Error THEN BEGIN
    ConvertChar := '#';
    FOR Ctr := 1 TO DecimalPos DO
      CaseStatement (Ctr);

    ConvertChar := '#';
    FOR Ctr := LENGTH (Mask) DOWNTO DecimalPos+1 DO
      CaseStatement (Ctr);
    END;

  IF Error THEN NumLow1_ConvertMask := StrFill ('?', MaskLength)
           ELSE NumLow1_ConvertMask := Mask;
END;

{=- NumLow1_ApplyMask -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}

FUNCTION NumLow1_ApplyMask (NumStr,
                           MaskStr  : STRING;
                           Negative : BOOLEAN;
                           RealMask : BOOLEAN) : STRING;

{RealMask must be true to properly line up decimal points.  If it is false
 decimal points are simply ignored (i.e. printed).}

{destroys the local copy of MaskStr!}

VAR
  Found     : BOOLEAN;
  MaskCtr   : INTEGER;
  MaskMax   : INTEGER;
  MaskDeci  : INTEGER;
  NumCtr    : INTEGER;
  NumMax    : INTEGER;
  NumDeciStr  : STRING;
  OverFlow  : BOOLEAN;
  SignFound : BOOLEAN;
  BothFound : BOOLEAN;

BEGIN
  OverFlow := FALSE;
  MaskMax  := LENGTH (MaskStr);
  NumMax   := LENGTH (NumStr);

  IF MaskStr [1] <> '?' THEN BEGIN
  MaskDeci := LENGTH (MaskStr);

  {If a real number, but an integer mask type}
  IF POS('.', MaskStr) = 0 THEN RealMask := FALSE;

    {Copy the number into the mask Real only}
    IF RealMask THEN BEGIN
      NumDeciStr := '.'+StrField (NumStr,'.',2);
      NumStr     := StrField (NumStr,'.',1);
      NumMax     := LENGTH (NumStr);

      {Strip off trailing zeros}
      NumCtr   := LENGTH (NumDeciStr);
      WHILE (NumDeciStr [NumCtr] = '0') AND (NumCtr > 1) DO
        NumCtr := PRED (NumCtr);
      NumDeciStr [0] := CHR (NumCtr);

      {Fill mask after the decimal point}
      MaskDeci   := POS ('.', MaskStr);
      IF MaskDeci > 0 THEN BEGIN
        MaskDeci := PRED (MaskDeci);  {Ignore the actual period char}
        MaskCtr  := MaskDeci+2;
        FOR NumCtr := 2 TO LENGTH (NumDeciStr) DO BEGIN
          Found  := FALSE;
          REPEAT
            IF NOT(MaskStr[MaskCtr] IN ['#','*','0']) THEN
              MaskCtr := SUCC(MaskCtr)
            ELSE
              Found := TRUE;
          UNTIL Found;
          MaskStr [MaskCtr] := NumDeciStr [NumCtr];
          MaskCtr := SUCC(MaskCtr);
          END;

        {Clean up trailing mask characters}
        MaskCtr := POS ('.', MaskStr);
        MaskMax := LENGTH (MaskStr);
        IF MaskCtr > 0 THEN BEGIN
          FOR MaskCtr := MaskCtr TO PRED(MaskMax) DO BEGIN
            IF MaskStr [MaskCtr] = '#' THEN MaskStr [MaskCtr] := ' ';
            IF (MaskStr [MaskCtr] = '.') AND (MaskStr [MaskCtr+1] = '#') THEN
              MaskStr [MaskCtr] := ' ';
            IF MaskStr [MaskCtr] = ',' THEN
              IF MaskStr [MaskCtr+1] IN ['*','0'] THEN
                MaskStr [MaskCtr] := MaskStr [MaskCtr+1]
              ELSE
                MaskStr [MaskCtr] := ' ';
            END;
          IF MaskStr [MaskMax] = '#' THEN MaskStr [MaskMax] := ' ';
          END;
        END;
      END;

    {Copy Number into the Mask integer and real}

    MaskCtr := MaskDeci;
    FOR NumCtr := NumMax DOWNTO 1 DO BEGIN
      IF MaskCtr > 0 THEN BEGIN
        Found := FALSE;
        REPEAT
          IF NOT(MaskStr[MaskCtr] IN ['#','*','0']) THEN
            MaskCtr := PRED(MaskCtr)
          ELSE
            Found := TRUE;
          UNTIL Found OR (MaskCtr = 0);
        OverFlow := (MaskCtr = 0);
        END
      ELSE OverFlow := TRUE;

      IF MaskCtr > 0 THEN BEGIN
        MaskStr [MaskCtr] := NumStr [NumCtr];
        MaskCtr := PRED(MaskCtr);
        END;
      END;

    {Clean up leading mask characters}
    IF NOT OverFlow THEN BEGIN
      FOR MaskCtr := MaskCtr DOWNTO 2 DO BEGIN
        IF MaskStr [MaskCtr] = '#' THEN MaskStr [MaskCtr] := ' ';
        IF MaskStr [MaskCtr] = ',' THEN
          IF MaskStr [MaskCtr-1] IN ['*','0'] THEN
            MaskStr [MaskCtr] := MaskStr [MaskCtr-1]
          ELSE
            MaskStr [MaskCtr] := ' ';
        END;
      IF MaskStr [1] = '#' THEN MaskStr [1] := ' ';

      {Move the sign flag next to the number}
      SignFound := (MaskStr [1] IN ['-','+','(']) OR
                   (MaskStr [LENGTH(MaskStr)] IN ['-','+',')']);
      BothFound := (POS('$-',MaskStr) > 0) OR (POS('-$',MaskStr) > 0);
      OverFlow  := (LENGTH (MaskStr) = 1);
      {Move leading sign}
      FOR MaskCtr := 1 TO MaskMax-1 DO
        IF (MaskStr [MaskCtr] IN ['-','+','(','$']) AND
           (MaskStr [MaskCtr+WORD(BothFound)+1] = ' ') THEN BEGIN
          IF MaskStr[MaskCtr] <> '$' THEN SignFound := TRUE;
          MOVE(MaskStr[MaskCtr],MaskStr[MaskCtr+1],WORD(BothFound)+1);
          MaskStr [MaskCtr]   := ' ';
          END;
      {Move trailing sign flag}
      FOR MaskCtr := LENGTH (MaskStr) DOWNTO 2 DO
        IF (MaskStr [MaskCtr] = ')') AND (MaskStr [MaskCtr-1] = ' ') THEN BEGIN
          MaskStr [MaskCtr-1] := ')';
          MaskStr [MaskCtr]   := ' ';
          END;
      OverFlow := (Negative AND (NOT SignFound));
      END;

    END;

  {Assign value to the Function -- check for overflow}
  IF OverFlow THEN NumLow1_ApplyMask := StrFill ('*', MaskMax)
              ELSE NumLow1_ApplyMask := MaskStr;
END;

(******************************************************************)

{ Vtype will either be 1 for INTEGER or 2 for LONGINT       }
{       currently examined by the hex conversion routine to }
{       determine the number of leading zeros to pad to the }
{       output hex string                                   }

FUNCTION Num2S (Vtype : VarType;
                Num : LONGINT; Mask : STRING) : STRING;

VAR
  Negative  : BOOLEAN;
  Base16    : BOOLEAN;

{=- Num2S -=- MaskBase =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}

  FUNCTION MaskBase : BYTE;
  {Returns the base specified in the Mask string.  Valid bases are:

     # - Base 10 - returns value 10
     H - Base 16 - returns value 16
     O - Base  8 - returns value  8
     B - Base  2 - returns value  2

  If an error is found in specifying a base (i.e. both #'s and H's) the
  returned value is zero.  Also if no base character is found the returned
  code is zero. }

  VAR
    Ctr  : BYTE;
    Base : BYTE;
    StarOrAtFound : BOOLEAN;

  BEGIN {MaskBase}
    Base := 255;
    StarOrAtFound := FALSE;

    FOR Ctr := 1 TO LENGTH (Mask) DO
      CASE Mask [Ctr] OF
        '#'     : IF (Base = 255) OR (Base = 10) THEN Base := 10 ELSE Base := 0;
        'H','h' : IF (Base = 255) OR (Base = 16) THEN Base := 16 ELSE Base := 0;
        'O','o' : IF (Base = 255) OR (Base =  8) THEN Base :=  8 ELSE Base := 0;
        'B','b' : IF (Base = 255) OR (Base =  2) THEN Base :=  2 ELSE Base := 0;
        '@','*' : StarOrAtFound := TRUE;
        ELSE    ;
        END; {CASE}

    {The Star and @ chars alone are base 10, otherwise they are any base}
    IF (Base = 255) AND StarOrAtFound THEN Base := 10;
    IF (Base = 255) THEN Base := 0;

    Base16 := (Base = 16);
    MaskBase := Base;
  END; {MaskBase}

{=- Num2S -=- ConvertToBase -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}

  FUNCTION ConvertToBase : STRING;
  CONST
    Hex : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';

  VAR
    BaseStr : STRING;
    HiWord,               (* high order 2 bytes of longint *)
    LoWord  : LONGINT;    (* low  order 2 bytes of longint *)
    Size    : INTEGER;
    Ctr     : INTEGER;

  BEGIN {ConvertToBase}
    Negative := FALSE;
    BaseStr  := '';
    Size := LENGTH (Mask);

    HiWord := Num shr 16;            (* used for hex and binary conversions *)
    LoWord := (Num shl 16) shr 16;   (*                                     *)

    {Convert the number into the correct base}
    CASE MaskBase OF
      10 : BEGIN
             Negative := (Num < 0);
             Num      := ABS (Num);
             STR (Num:Size, BaseStr);
           END;

      16 : BEGIN   (* handles LONGINTs *)

             (* BaseStr will have a length of 8 *)

             BaseStr := Hex[HI(HiWord) SHR 4] + Hex[HI(HiWord) AND $0F] +
                        Hex[LO(HiWord) SHR 4] + Hex[LO(HiWord) AND $0F] +
                        Hex[HI(LoWord) SHR 4] + Hex[HI(LoWord) AND $0F] +
                        Hex[LO(LoWord) SHR 4] + Hex[LO(LoWord) AND $0F];

             (* delete the 4 leading 0's for INTEGERs *)
             if VType = S_INT then Delete(BaseStr,1,4);

             (* delete leading 0's if longer than mask *)
             WHILE (Length(BaseStr) > Size) and (BaseStr[1] = '0') do
                Delete(BaseStr,1,1);

           END;

       2 : BEGIN
             (* convert the first 2 bytes *)
             FOR Ctr := 0 TO 15 DO
               BaseStr := Hex[(LoWord SHR Ctr) AND $01] + BaseStr;

             (* convert the next 2 bytes *)
             FOR Ctr := 0 TO 15 DO
               BaseStr := Hex[(HiWord SHR Ctr) AND $01] + BaseStr;

             (* delete the 16 leading 0's for INTEGERs *)
             if VType = S_INT then Delete(BaseStr,1,16);

             (* delete leading 0's if longer then mask *)
             WHILE (Length(BaseStr) > Size) and (BaseStr[1] = '0') do
                Delete(BaseStr,1,1);

           END;

      ELSE BaseStr := StrFill ('?', Size);
      END;
    ConvertToBase := Strip(BaseStr,S_Leading+S_Trailing);
  END; {ConvertToBase}

{=- Num2S -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}

VAR
  TempStr  : STRING;
  Size     : INTEGER;
  TempMask : STRING;

BEGIN
  Size     := LENGTH (Mask);
  TempStr  := ConvertToBase;
  IF (Num = 0) AND (NOT Base16) THEN TempStr := '';
  TempMask := NumLow1_ConvertMask (Mask, Negative, FALSE);
  TempStr  := RJS (NumLow1_ApplyMask (TempStr, TempMask, Negative, FALSE), Size);
  Num2S      := TempStr;

END; (* Num2S *)

(******************************************************************)

FUNCTION L2S (Num : LONGINT; Mask : STRING) : STRING;

   begin
      L2S := Num2S(L_INT,Num,Mask);
   end; (* L2S *)

(******************************************************************)

FUNCTION I2S(Num : INTEGER; Mask : STRING) : STRING;

   begin
      I2S := Num2S(S_INT,Num,Mask);
   end; (* I2S *)

(******************************************************************)

FUNCTION W2S(Num : WORD; Mask : STRING) : STRING;

   begin
      W2S := Num2S(S_INT,Num,Mask);
   end; (* W2S *)

(******************************************************************)

FUNCTION Real2S(Num : DOUBLE; Mask : STRING) : STRING;
VAR
  TempStr  : STRING;
  Size     : INTEGER;
  Places   : INTEGER;
  Ctr      : INTEGER;
  Negative : BOOLEAN;
  TempMask : STRING;

BEGIN
  Negative := (Num < 0);
  Num      := ABS (Num);
  Size     := LENGTH (Mask);
  TempMask := NumLow1_ConvertMask (Mask, Negative, TRUE);

  {Count the number of places after the decimal point}
  Places := 0;
  Ctr := POS ('.', TempMask);
  IF Ctr > 0 THEN
    FOR Ctr := Ctr TO LENGTH (TempMask) DO
      IF TempMask [Ctr] IN ['#','*','0'] THEN
        Places := SUCC(Places);
  IF Places > 20 THEN Places := 20;

  STR (Num:Size:Places, TempStr);
  TempStr  := Strip (TempStr, S_Leading+S_Trailing);
  IF Num = 0 THEN TempStr := '';
  TempStr  := RJS (NumLow1_ApplyMask (TempStr, TempMask, Negative, TRUE), Size);
  Real2S      := TempStr;
END;

(******************************************************************)

FUNCTION R2S(Num : REAL; Mask : STRING) : STRING;

   begin
      R2S := Real2S(Num,Mask);
   end; (* R2S *)

(******************************************************************)

FUNCTION D2S(Num : DOUBLE; Mask : STRING) : STRING;

   begin
      D2S := Real2S(Num,Mask);
   end; (* D2S *)

(******************************************************************)

{.PA}

FUNCTION S2Real (Source : STRING) : DOUBLE;

VAR
  Ctr    : INTEGER;
  Code   : INTEGER;
  NumStr : STRING;
  Num    : DOUBLE;
  Negative : BOOLEAN;

BEGIN
  Negative := FALSE;
  NumStr := '';
  {Strip out any non-numerals - set the negative flag if necessary}
  FOR Ctr := 1 TO LENGTH (Source) DO
    IF Source [Ctr] IN ['0'..'9','.'] THEN
      NumStr := NumStr + Source [Ctr]
    ELSE IF Source [Ctr] IN ['-','('] THEN
      Negative := TRUE;

  {Force the null string to zero}
  IF NumStr = '' THEN NumStr := '0';

  {Force the correct sign}
  IF Negative THEN NumStr := '-' + NumStr;

  IF NumStr[LENGTH(NumStr)] IN ['.','-'] THEN NumStr := NumStr + '0';
  VAL (NumStr, Num, Code);
  IF Code <> 0 THEN BEGIN
    ScrErrMsg ('Tried to convert "'+NumStr+'", error in character #'+I2S(Code,'####@'));
    S2Real := 0;   { Abend (2, NIL); }
    END
  ELSE
    S2Real := Num;
END;

(******************************************************************)

FUNCTION S2R (Source : STRING) : REAL;

   begin
      S2R := S2Real(Source);
   end; (* S2R *)

(******************************************************************)

FUNCTION S2D (Source : STRING) : DOUBLE;

   begin
      S2D := S2Real(Source);
   end; (* S2D *)

(******************************************************************)

FUNCTION StrNumTest (Fld : STRING) : StrNumType;

VAR
  Ctr     : WORD;
  TempStr : STRING;
  StrNum  : StrNumType;

BEGIN
  StrNum := StrNonNumeric;
  Ctr := 1;
  WHILE (Ctr <= LENGTH(Fld)) AND (StrNum <> StrNonZero) DO BEGIN
    IF Fld[Ctr] IN ['0'..'9'] THEN IF Fld[Ctr] <> '0'
      THEN StrNum := StrNonZero
      ELSE StrNum := StrZero;
    INC(Ctr);
    END;
  StrNumTest := StrNum;
END;

FUNCTION S2X (Source : STRING; Min, Max : LONGINT) : LONGINT;

  FUNCTION Power2 (Pow : INTEGER) : LONGINT;
  {integers can never overflow in turbo they just wrap around!}
  VAR
    Ctr : INTEGER;
    Num : LONGINT;
  BEGIN
    Num := 1;
    FOR Ctr := 1 TO Pow DO
      Num := Num * 2;
    Power2 := Num;
  END;


CONST
  Unknown     = 0;
  Binary      = 1;
  Hexidecimal = 2;
  Decimal     = 3;

VAR
  SourceLen : INTEGER;
  Ctr       : INTEGER;
  Code      : INTEGER;
  NumStr    : STRING;
  Num       : LONGINT;
  Negative  : BOOLEAN;
  Base      : Unknown..Decimal;

BEGIN
  Base      := Unknown;
  Negative  := FALSE;
  NumStr    := '';
  Num       := 0;
  Code      := 0;
  SourceLen := LENGTH (Source);

  {Determine base (leading or trailing H) and set negative flag}
  FOR Ctr := 1 TO SourceLen DO
    IF Source [Ctr] IN ['-','('] THEN
      Negative := TRUE
    ELSE IF (Source [Ctr] IN ['H','h']) AND (Base = Unknown) THEN
      Base := Hexidecimal;

  {If base is unknown, see if it is base 10 or base 2 (Binary)}
  IF Base = Unknown THEN
    FOR Ctr := 1 TO SourceLen DO
      IF (Source [Ctr] IN ['B','b']) AND (Base = Unknown) THEN
      Base := Binary;

  {If base is still unknown, then it is base 10}
  IF Base = Unknown THEN Base := Decimal;

  {Strip out any non-numerals}
  CASE Base OF
    Decimal     : BEGIN
                    Ctr := 1;
                    WHILE (Ctr <= SourceLen) AND (Source[Ctr] <> '.') DO BEGIN
                      IF Source [Ctr] IN ['0'..'9'] THEN NumStr := NumStr + Source[Ctr];
                      INC(Ctr);
                      END;
                    END;

    Hexidecimal : BEGIN
                    NumStr := '$' + NumStr;
                    FOR Ctr := 1 TO SourceLen DO
                      IF Source [Ctr] IN ['0'..'9','A'..'F','a'..'f'] THEN
                        NumStr := NumStr + Source [Ctr];
                    END;

    Binary      : BEGIN
                    FOR Ctr := 1 TO SourceLen DO
                      IF Source [Ctr] IN ['0'..'1'] THEN
                        NumStr := NumStr + Source [Ctr];

                    FOR Ctr := LENGTH (NumStr) DOWNTO 1 DO
                      IF NumStr [Ctr] = '1' THEN
                        Num := Num + Power2(LENGTH(NumStr)-Ctr);
                    END;
    END; {CASE}

  {Force the null string to zero}
  IF NumStr = '' THEN NumStr := '0';

  {Force the correct sign}
  IF Negative THEN NumStr := '-' + NumStr;
  IF NumStr[LENGTH(NumStr)] IN ['-'] THEN NumStr := NumStr + '0';

  IF Base <> Binary THEN
    VAL (NumStr, Num, Code);

  IF Code <> 0 THEN BEGIN
    ScrErrMsg ('Tried to convert "'+NumStr+'", error in character #'+I2S(Code,'####@'));
    S2X := 0;    { Abend (2, NIL); }
    END
  ELSE IF (Num >= Min) AND (Num <= Max)
    THEN S2X := Num
    ELSE S2X := 0;

END;  (* S2X *)

(******************************************************************)

FUNCTION S2I(Source : STRING) : INTEGER;

   begin
      S2I := S2X(Source,-MAXINT-1,MAXINT);
   end; (* S2I *)

FUNCTION S2W(Source : STRING) : WORD;

   begin
      S2W := S2X(Source,0,MAXINT*2+1);
   end; (* S2W *)


FUNCTION S2L(Source : STRING) : LONGINT;

   begin
      S2L := S2X(Source,-MAXLONGINT-1,MAXLONGINT);
   end; (* S2I *)
(******************************************************************)

FUNCTION B2S (Flag : BOOLEAN) : STRING;

BEGIN
  IF Flag
    THEN B2S := 'TRUE'
    ELSE B2S := 'FALSE';
END;

{.PA}

(**************************************************************************)
(*                                                                        *)
(*          2)  Date and Time Formatting And Conversion                   *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

CONST
  MonthName   : ARRAY [1..12] OF DateTimeStr =
                ('January','February','March','April','May','June','July',
                 'August','September','October','November','December');

  WeekdayName : ARRAY [1..7] OF DateTimeStr =
                ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday',
                 'Saturday');

{.PA}

FUNCTION NumTh (Num : INTEGER) : STRING;
VAR
  TempStr : STRING;
  AddChar : STRING [2];

BEGIN
  TempStr := I2S(Num, '####@');
  IF NOT ((TempStr[4] = '1') AND (TempStr[5] IN ['1'..'3'])) THEN
    CASE TempStr [5] OF
      '1' : AddChar := 'st';
      '2' : AddChar := 'nd';
      '3' : AddChar := 'rd';
      ELSE  AddChar := 'th';
      END {CASE}
  ELSE
    AddChar := 'th';

  NumTh := TempStr + AddChar;
END;

PROCEDURE Date2R (VAR JulSec : REAL; DateTime : T_DateTime);
VAR
  MO,DA,YR : REAL;
  JUL,Sec  : REAL;

BEGIN
  WITH DateTime DO BEGIN
    MO := Month - 3;
    DA := Day;

    IF YEAR < 100 THEN YR := Year + 1900 - 1840
                  ELSE YR := Year - 1840;

    IF MO < 0 THEN BEGIN
      MO := MO+12;
      YR := YR-1;
      END;

    JUL := INT ((YR * 1461) / 4);
    JUL := INT ((((153 * MO) + 2) / 5)) + JUL + DA - 306;
    IF JUL > 21609 THEN JUL := JUL - 1;

    JUL := JUL * 86400.0;
    Sec := (Hour * 3600.0) + (Minute * 60.0) + Second;

    JulSec := JUL + Sec;
    END;
END;

PROCEDURE R2Date (JulSec : REAL; VAR DateTime : T_DateTime);
VAR
  NumberSecs : REAL;
  NumberDays : REAL;
  MO,DA,YR,J,W : REAL;
  TempWeekDay  : INTEGER;

BEGIN
  NumberDays := INT (JulSec / 86400.0);
  NumberSecs := INT (JulSec - (NumberDays * 86400.0));

  WITH DateTime DO BEGIN
    NumSeconds := JulSec;
    NumMinutes := JulSec / 60.0;
    NumHours   := JulSec / 3600.0;
    NumDays    := JulSec / 86400.0;

    Hour   := TRUNC (NumberSecs / 3600);
    Minute := TRUNC ((NumberSecs - (Hour * 3600.0)) / 60);
    Second := TRUNC (NumberSecs - (Hour * 3600.0) - (Minute * 60.0));

    {Gregorian Date Routine (Leap Centuries are OK)}
    J := NumberDays + 305;
    IF NumberDays > 21608 THEN J := J + 1;

    YR := INT ((4 * J + 3) / 1461);
    DA := INT (((J * 4 + 3) - (1461 * YR) + 4) / 4);
    MO := INT ((5 * DA - 3) / 153);

    DA := INT ((((5 * DA - 3) - (153 * MO)) + 5) / 5);
    MO := MO + 3;
    YR := YR + 1840;

    IF MO > 12 THEN BEGIN
      MO := MO - 12;
      YR := YR + 1;
      END;

    Day   := TRUNC (DA);
    Month := TRUNC (MO);
    Year  := TRUNC (YR);

    MonthStr := MonthName [Month];

    {Find the day of the week}
    TempWeekday := TRUNC (INT (NumberDays - (INT (NumberDays / 7) * 7) - 2));
    IF TempWeekDay < 1 THEN TempWeekDay := TempWeekDay + 7;
    WeekDay := TempWeekDay;
    WeekdayStr := WeekdayName [WeekDay];
    END;
END;

FUNCTION Date2S (DateTime : T_DateTime; Mask : STRING) : STRING;

  FUNCTION GetFormat (Source : STRING; LookFor : CHAR) : INTEGER;
  VAR
    Ctr : INTEGER;
  BEGIN
    Ctr := POS (LookFor , Source);
    Source := Source + ' ';
    WHILE (Source [Ctr] = LookFor) AND (Ctr < LENGTH (Source)) DO
      Ctr := SUCC (Ctr);
    GetFormat := Ctr - POS (LookFor, Source);
  END;

TYPE
  SelectType = ARRAY [2..4] OF STRING[9];

VAR
  Ctr      : INTEGER;
  WeekdayFmt,
  MonthFmt,
  DayFmt,
  YearFmt  : INTEGER;
  TempStr  : STRING;
  AmPm     : BOOLEAN;
  TempHour : INTEGER;
  MaskSet  : SET OF CHAR;
  Select   : SelectType;
  Europe   : BOOLEAN;      { YY/DD/MM versus MM/DD/YY }

  PROCEDURE Doit (MaskChar  : CHAR; SelectNum : INTEGER);
  BEGIN
    IF SelectNum < 2 THEN SelectNum := 2
    ELSE IF SelectNum > 4 THEN SelectNum := 4;
    WHILE (Ctr < LENGTH (Mask)) AND (NOT (Mask [Ctr] IN MaskSet)) DO BEGIN
      TempStr := TempStr + Mask [Ctr];
      Ctr := SUCC(Ctr);
      END;

    IF Mask [Ctr] = MaskChar THEN BEGIN
      TempStr := TempStr + Select [SelectNum];
      Ctr := Ctr + SelectNum;
      END;
  END;

  PROCEDURE DoMonth;
  BEGIN
    WITH DateTime DO BEGIN
      Select [2] := I2S  (Month, '@@');
      Select [3] := COPY (MonthStr,1,3);
      Select [4] := MonthStr;
      Doit ('M', MonthFmt);
      MaskSet    := MaskSet - ['M'];
      END;
  END;

  PROCEDURE DoDay;
  BEGIN
    WITH DateTime DO BEGIN
      Select [2] := I2S  (Day, '@@');
      Select [3] := 'Error';
      Select [4] := Strip (NumTh (Day), S_Leading);
      Doit ('D', DayFmt);
      MaskSet    := MaskSet - ['D'];
      END;
  END;

  PROCEDURE DoYear;
  BEGIN
    WITH DateTime DO BEGIN
      Select [2] := COPY (I2S (Year, '@@@@'),3,2);
      Select [3] := 'Error';
      Select [4] := I2S (Year, '@@@@');
      Doit ('Y', YearFmt);
      MaskSet    := MaskSet - ['Y'];
      END;
  END;

  PROCEDURE CheckEuropeDate;
  VAR
    EuropePos : WORD;
  BEGIN
    EuropePos := POS('E',Mask);
    IF EuropePos <> 0 THEN BEGIN
      Europe := TRUE;
      Mask := COPY(Mask,1,EuropePos-1) + COPY(Mask,EuropePos+1,LENGTH(Mask));
      END
    ELSE Europe := FALSE;
  END;

BEGIN  { Date2S }
  CheckEuropeDate;
  TempStr    := '';
  WeekdayFmt := 0;
  MonthFmt   := 0;
  DayFmt     := 0;
  YearFmt    := 0;

  WeekdayFmt := GetFormat (Mask, 'W');
  MonthFmt   := GetFormat (Mask, 'M');
  DayFmt     := GetFormat (Mask, 'D');
  YearFmt    := GetFormat (Mask, 'Y');

  AmPm := FALSE;

  {Add a blank the the end of the mask so we don't have to test if Ctr is
   past the end of the string every time.  (Since multiple conditions in IF
   statements don't short circuit, for example:

     IF (Ctr < LENGTH (Mask)) AND (Mask [Ctr] = ' ') THEN ..

   will still generate a runtime error (with $r+) at the instruction
   Mask [Ctr], if Ctr is greater than the length of the string Mask!)}

  Mask := Mask + ' ';

  {Search for AmPm indicator}
  FOR Ctr := 1 TO LENGTH (Mask) DO
    CASE Mask [Ctr] OF
      'a' : BEGIN
              IF DateTime.Hour > 11 THEN Mask [Ctr] := 'p';
              AmPm := TRUE;
              END;
      'p' : BEGIN
              IF DateTime.Hour < 12 THEN BEGIN
                Mask [Ctr] := ' ';
                IF Mask [SUCC(Ctr)] = 'm' THEN Mask [SUCC(Ctr)] := ' ';
                END;
              AmPm := TRUE;
              END;
      END;

  Ctr  := 1;


  WITH DateTime DO BEGIN
    MaskSet    := ['W','M','D','Y','h','m','s'];
    Select [2] := 'Error';
    Select [3] := COPY (WeekdayStr,1,3);
    Select [4] := WeekdayStr;
    Doit ('W', WeekdayFmt);
    MaskSet    := MaskSet - ['W'];

    IF NOT Europe THEN BEGIN
      DoMonth;
      DoDay;
      DoYear;
      END
    ELSE BEGIN
      DoYear;
      DoMonth;
      DoDay;
      END;

    WHILE (Ctr < LENGTH (Mask)) AND (NOT (Mask [Ctr] IN ['h','m','s'])) DO BEGIN
      TempStr := TempStr + Mask[Ctr];
      Ctr := SUCC(Ctr);
      END;

    IF (Mask [Ctr] = 'h') AND (Mask [SUCC(Ctr)] = 'h') THEN BEGIN
      TempHour := Hour;
      IF AmPm THEN
        IF      Hour = 0  THEN TempHour := 12
        ELSE IF Hour > 13 THEN TempHour := Hour - 12;

      TempStr := TempStr + I2S (TempHour, '@@');
      Ctr := Ctr + 2;
      END;

    WHILE (Ctr < LENGTH (Mask)) AND (NOT (Mask [Ctr] IN ['m','s'])) DO BEGIN
      TempStr := TempStr + Mask[Ctr];
      Ctr := SUCC(Ctr);
      END;

      IF (Mask [Ctr] = 'm') AND (Mask [SUCC(Ctr)] = 'm') THEN BEGIN
        TempStr := TempStr + I2S (Minute, '@@');
        Ctr := Ctr + 2;
        END;

    WHILE (Ctr < LENGTH (Mask)) AND (NOT (Mask [Ctr] IN ['s'])) DO BEGIN
      TempStr := TempStr + Mask[Ctr];
      Ctr := SUCC(Ctr);
      END;

    IF (Mask [Ctr] = 's') AND (Mask [SUCC(Ctr)] = 's') THEN BEGIN
      TempStr := TempStr + I2S (Second, '@@');
      Ctr := Ctr + 2;
      END;
    END;

    IF Ctr < LENGTH (Mask) THEN
      REPEAT
        TempStr := TempStr + Mask[Ctr];
        Ctr := SUCC(Ctr);
        UNTIL Ctr > LENGTH (Mask) - 1;

  Date2S := TempStr;
END;

PROCEDURE GetDOSDateAndTime (VAR JulSec : REAL; VAR DateTime : T_DateTime);

VAR
  DosReg : Registers;

BEGIN
  WITH DosReg, DateTime DO BEGIN
    AH := $2A;  {DOS Date}
    AL := $00;
    INTR (_DOS,DosReg);

    WeekDay    := AL+1;
    WeekdayStr := WeekdayName [AL+1]; { DOS returns the week day in AL,}
    MonthStr   := MonthName   [DH];
    Year       := CX;                 { the year in CX,                }
    Month      := DH;                 { the month in DH,               }
    Day        := DL;                 { and the day in DL.             }

    AH := $2C;  {DOS Time}
    AL := $00;
    INTR (_DOS, DosReg);

    Hour   := CH;            { DOS returns the hours in CH,   }
    Minute := CL;            { the minutes in CL,             }
    Second := DH;            { the seconds in DH, and the     }
    END;

  {Update NumDays, NumHours, NumMinutes, and NumSeconds}
  Date2R (JulSec, DateTime);
  R2Date (JulSec, DateTime);
END;

PROCEDURE SetDOSDateAndTime (DateTime : T_DateTime);

VAR
  DosReg : Registers;

BEGIN
  WITH DosReg, DateTime DO BEGIN
    CX := Year;  { the year in CX,    }
    DH := Month; { the month in DH,   }
    DL := Day;   { and the day in DL. }

    AH := $2B;  {Set DOS Date}
    AL := $00;
    INTR (_DOS,DosReg);

    CH := Hour;   { the hours in CH,   }
    CL := Minute; { the minutes in CL, }
    DH := Second; { the seconds in DH. }

    AH := $2D;  {Set DOS Time}
    AL := $00;
    INTR (_DOS, DosReg);
    END;
END;